CU Amiga Super CD-ROM 27

home *** CD-ROM | disk | FTP | other *** search

/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / ODE / obj_binding < prev next >

Wrap

Text File | 1992-01-22 | 7.8 KB | 339 lines

\ BINDING for Object Oriented Development Environment \ \ This code provides words for binding a message to the appropriate \ method for an object. Binding can occur at compile time ( "EARLY" ), \ or at run time, ( "LATE" ) \ \ Author: Phil Burk \ Copyright 1986 Phil Burk \ \ MOD: PLB 11/29/86 Added MAC RO calls. \ For relocating systems, like on the MAC, relocatable tokens \ are stored in the dictionary, and absolute addresses are used at \ run time (when possible ). The object stack contains absolute \ addresses. The CFAs for methods are stored as relocatable tokens. \ MOD: PLB 5/13/87 Change OS-STACK-PTR to OSSTACKPTR for Mac \ MOD: PLB 5/24/87 Compile time check for Illegal Method. \ MOD: PLB 9/6/87 Add binding for Instance Objects. \ MOD: PLB 9/8/87 Preshift late bound offset in OB.LATE.BIND \ mdh 7/2/88 changed appropriate 'literal's to 'aliterals's \ MOD: PLB 7/25/88 USE OB.OBJ->CFA_BASE in OB.BIND.RUN \ MOD: PLB 11/27/90 Warn if recursive call to self. \ 00001 PLB 10/24/91 Allow binding to local variables. \ 00002 PLB 11/12/91 Call LOCAL.REFERENCE to force fetch. \ 00003 PLB 1/22/92 Assembled OB.BAD.CLASS? and added odd check. ANEW TASK-OBJ_BINDING ( Bind a method found in a CFA array. ) ( Object base holds a pointer to an array of method CFAS ) : OB.OBJ->CFA_BASE ( use_obj_base -- use_cfa_base ) @ rel->use ( relocate rel_cfa_base ) ; : OB.OBJ->CLASS ( use_obj_base -- use_class_base ) @ rel->use ob_cfas - ; : OB.CFA@ ( use_obj_base method_index -- rel_method_cfa , CFA for method ) cell* swap @ rel->use + @ ; \ Error Checking for binding -------------------------------------- : OB.VALID? ( rel_object -- true_if_ok ) rel->use ob.obj->class dup 1 and 0= ( is it even? ) IF ..@ ob_valid_key ob_valid.key = ELSE drop FALSE THEN ; host=amiga .IF \ 00003 ASM OB.BAD.CLASS? ( use_class_base -- bad? ) BTST #0,D7 \ is it odd? BNE 1$ MOVE.L [ob_valid_key](org,tos),d7 CMP.L #[ob_valid.key],d7 \ does key match? BNE 1$ MOVEQ.L #0,TOS RTS 1$: MOVEQ.L #-1,TOS RTS END-CODE .ELSE : OB.BAD.CLASS? ( use_class_base -- bad? ) dup 1 and IF drop true ELSE ..@ ob_valid_key ob_valid.key = NOT THEN ; .THEN : OB.CHECK.CLASS ( use_class_base -- , abort if not a class ) ob.bad.class? IF " OB.CHECK.CLASS" " Not an ODE object or class!" er_fatal er.report THEN ; : OB.CHECK.METHOD ( method_index use_class_base -- , abort if bad method ) ..@ ob_#methods > IF " OB.CHECK.METHOD" " Method not supported for that object!" er_fatal er.report THEN ; : OB.CHECK.BIND ( use_obj_base method_index -- , abort if bad ) swap ob.obj->class dup ob.check.class ob.check.method ; \ DO compile time checking for illegal methods. : OB.CHECK.ILLEGAL ( rel_method_cfa -- ) rel->use 'c ob.bad.method = IF " OB.CHECK.ILLEGAL" " Method not defined for this class." er_fatal er.report THEN ; \ Compile code to execute method for an object. --------------- #HOST_AMIGA_JFORTH .IF : OB.BIND.CFA ( use_obj_base rel_method_cfa -- , binds method to object ) dup ob.check.illegal swap STATE @ IF [compile] aliteral compile os.push calladr, compile os.drop ELSE os.push execute os.drop THEN ; : OB.BIND.INSTANCE.CFA ( instance_offset rel_method_cfa -- ) dup ob.check.illegal swap state @ IF [compile] literal compile os+push calladr, compile os.drop ELSE os+push execute os.drop THEN ; .THEN #HOST_MAC_H4TH .IF : (OB.EXEC.METHOD) ( rel_method_cfa rel_obj_base -- ) rel->use os.push ro.execute os.drop ; : OB.BIND.CFA ( use_obj_base rel_method_cfa -- , binds method to object ) dup ob.check.illegal STATE @ IF [compile] literal ( cfa ) use->rel [compile] literal ( obj_base ) compile (ob.exec.method) ELSE swap os.push ro.execute os.drop THEN ; : (OB.EXEC.METHOD.I) ( rel_method_cfa offset -- ) os+push ro.execute os.drop ; : OB.BIND.INSTANCE.CFA ( instance_offset rel_method_cfa -- ) dup ob.check.illegal state @ IF [compile] literal ( cfa ) [compile] literal ( offset ) compile (ob.exec.method.i) ELSE swap os+push ro.execute os.drop THEN ; .THEN variable OB-IF-CHECK-BIND variable OB-CURRENT-MIND \ currently compiling method index #host_amiga_jforth .IF max-inline @ 200 max-inline ! ( optimize !! ) : OB.CHECK.BIND.RUN ( rel_obj method_index*4 -- rel_obj method_index*4 ) 2dup 4/ ob.check.bind ; max-inline ! ASM OB.BIND.RUN ( rel_obj method_index*4 -- , run time binding act) move.l [ ob-if-check-bind here - 2- ](pc),d0 beq.s 1$ callcfa ob.check.bind.run 1$: move.l tos,d2 \ D2 = method*4 move.l (dsp)+,tos move.l tos,d3 \ D3 = rel_obj callcfa os.push move.l $0(org,d3.l),D0 \ D0 = rel address of CFA table add.l d2,d0 move.l $0(org,d0.l),D1 \ D1 = rel address of method jsr $0(org,d1.l) callcfa os.drop rts END-CODE .ELSE : OB.BIND.RUN ( rel_obj_base method_index*4 -- , run time binding act) >r rel->use ob-if-check-bind @ IF dup r@ 4/ ob.check.bind THEN dup os.push ( push object onto object stack ) @ rel->use r> + ( index to method cfa ) @ rel->use execute ( Perform method on object. ) os.drop ; .THEN : OB.LATE.BIND ( [rel_obj_base] method_index -- , do late binding of method ) \ rel_obj_base not present at compile time. STATE @ IF cell* ( preshift for faster run time ) [compile] literal ( save method index for late binding ) compile ob.bind.run ELSE cell* ob.bind.run THEN ; : SELF ( -- rel_obj_base, of_self ) os.copy use->rel ( %R ) ; EXISTS? [] NOT .IF : [] ( -- , use late binding if 'method: []' ) " OBJECT USE" " '[]' CAN ONLY BE AFTER A METHOD" er_fatal er.report ; .THEN : SUPER ( --- , stub for superbinding ) " OBJECT USE" " 'SUPER' can only be used inside a METHOD definition" er_fatal er.report ; \ Binding with super-dooper uses the method defined in a superclasses' \ superclass. : SUPER-DOOPER ( --- , stub for superbinding with skip ) " OBJECT USE" " 'SUPER-DOOPER' can only be used inside a METHOD definition" er_fatal er.report ; #HOST_AMIGA_JFORTH .IF : OB.BIND.'BASE ( CFA -- , bind CFA to current object ) ?comp calladr, ; .THEN #HOST_MAC_H4th .IF : OB.BIND.'BASE ( rel_CFA -- , bind CFA to current object ) ?comp [compile] literal compile ro.execute ; .THEN \ These words work off of a variable that contains an use_cfa_base. : OB.BIND.VAR ( method_index cfa_base_variable -- , bind from that variable ) @ swap cell* + @ ( -- method_cfa ) dup ob.check.illegal ob.bind.'base ( %? ) ; : OB.BIND.INSTANCE ( method_index pfa_object_def -- ) dup ..@ obi_offset ( get offset ) -rot ..@ obi_rel_class rel->use .. ob_cfas ( -- off mi acfas ) swap cell* + @ ob.bind.instance.cfa ; : OB.BIND.NORMAL ( method_index pfa_object -- ) dup rot 2dup ob.check.bind ob.cfa@ ob.bind.cfa ; : OB.EARLY.BIND ( method_index cfa_object -- ) cfa->pfa ob-state @ ob_def_class = IF dup ob-current-class @ ob.is.instance? ( Check to see if this is an Instance Object.) IF ob.bind.instance ELSE ob.bind.normal THEN ELSE ob.bind.normal THEN ; : OB.FIND.OBJECT ( <object> -- cfa , abort if not found ) bl word find NOT IF >newline count type ." ?" cr " OB.FIND.OBJECT" " Object not found!" er_fatal er.report THEN ; : OB.CHECK.RECURSE ( method_index -- , warn in recurse: self ) ob-current-mind @ = IF " OB.CHECK.RECURSE" " Recursive message to self!" er_warning er.report current-method @ id. ." SELF" cr THEN ; : OB.BIND ( method_index <object> -- , bind ) ob.find.object ( -- mi cfa ) CASE ( Different types of binding. ) \ Assume rel_obj_base also on stack at runtime for late binding. 'c [] OF ob.late.bind ENDOF \ \ allow automatic late bind to locals 00001 'c local.reference OF [compile] local.reference ob.late.bind \ 00002 ENDOF \ 'c SELF OF dup ob.check.recurse ob-self-cfas ob.bind.var ENDOF \ 'c SUPER OF ob-super-cfas ob.bind.var ENDOF \ 'c SUPER-DOOPER OF ob-dooper-cfas ob.bind.var ENDOF \ \ Bind named object. ob.early.bind 0 ( needs zero for dropping ) ENDCASE ;